unit VFrames;

// Simplyfied wrapper for VSample
//
// michael@grizzlymotion.com

interface


USES Windows, Messages, Controls, Forms, SysUtils, Graphics, MMSystem,VSample;

TYPE
  TVideoImage = class
                  private
                    VideoSample   : TVideoSample;
                    OnNewFrameBusy: boolean;
                    fVideoRunning : boolean;
                    fWidth,
                    fHeight       : integer;
                    fBitmap       : TBitmap;
                    fDisplayCanvas: TCanvas;
                  public
                    constructor Create;
                    procedure Free;
                    property  VideoRunning : boolean read fVideoRunning;
                    property  VideoWidth: integer read fWidth;
                    property  VideoHeight: integer read fHeight;
                    procedure VideoStop;
                    function  VideoStart(DeviceName: string): integer;
                    procedure CallBack(pb : pbytearray; var Size: integer);
                    procedure OnNewFrame(VAR Msg: TMessage); message WM_NewFrame;
                    procedure GetBitmap(BMP: TBitmap);
                    procedure SetDisplayCanvas(Canvas: TCanvas);
                    procedure ShowProperty;
                    procedure ShowProperty_Stream;
                end;



implementation

VAR
  fFrameCnt    :integer = 0;
  f30FrameTick :integer = 0;
(* Dammit, won't function! Don't know why. Runs for about 100 images and than stops working....*)
procedure TVideoImage.CallBack(pb : pbytearray; var Size: integer);
VAR
  W, H   : integer;
  FourCC : cardinal;
  hr     : HResult;
  T1     : integer;
  st     : string;
begin
  inc(fFrameCnt);
  if OnNewFrameBusy then exit;
  OnNewFrameBusy := true;
  if fFrameCnt mod 30 = 0 then
    begin
      T1 := TimeGetTime;
      if f30FrameTick > 0 then
        st := 'fps: ' + FloatToStrf(30000 / (T1-f30FrameTick), ffFixed, 16, 1);
      f30FrameTick := T1;
    end;
  try
    IF Size <> fWidth*fHeight*3 then
      begin
        OnNewFrameBusy := false;
        exit;
      end;
    move(pb^, FBitmap.scanline[fHeight-1]^, Size);
    if assigned(fDisplayCanvas) then
      IF fDisplayCanvas.LockCount < 1 then
        begin
          fDisplayCanvas.lock;
          try
            fDisplayCanvas.Draw(0, 0, fBitmap);
          finally
            fDisplayCanvas.unlock;
          end;
        end;
  finally
    OnNewFrameBusy := false;
  end;
end;



constructor TVideoImage.Create;
begin
  inherited Create;
  fVideoRunning := false;
  OnNewFrameBusy:= false;
  fBitmap := TBitmap.Create;
  fDisplayCanvas := nil;
  fWidth := 0;
  fHeight := 0;
end;


procedure TVideoImage.Free;
begin
  fDisplayCanvas := nil;
  fBitmap.Free;
  inherited Free;
end;


procedure TVideoImage.VideoStop;
begin
  if not assigned(VideoSample) then
    exit;
  fDisplayCanvas := nil;
  Screen.Cursor := crHourGlass;
  Application.ProcessMessages;
  try
    VideoSample.Free;
    VideoSample := nil;
  except
  end;
  fVideoRunning := false;
  Screen.Cursor := crDefault;
  Application.ProcessMessages;
end;



function TVideoImage.VideoStart(DeviceName: string): integer;
VAR
  hr     : HResult;
  st     : string;
  W, H   : integer;
  FourCC : cardinal;
begin
  Result := 0;
  if assigned(VideoSample) then
    VideoStop;
  Screen.Cursor := crHourGlass;
  Application.ProcessMessages;

  VideoSample := TVideoSample.Create(Application.MainForm.Handle, true, HR); // Force RGB24
  try
    hr := VideoSample.StartVideo(DeviceName, false, st) // Not visible. Displays itself...
  except
    hr := -1;
  end;

  if Failed(hr)
    then begin
      VideoStop;
     // SpeedButton_RunVideo.Down := false;
     // ShowMessage(DXGetErrorDescription9A(hr));
     Result := 1;
    end
    else begin
      hr := VideoSample.GetStreamInfo(W, H, FourCC);
      IF Failed(HR)
        then begin
          VideoStop;
          Result := 1;
        end
        else BEGIN
          fWidth := W;
          fHeight := H;
          FBitmap.PixelFormat := pf24bit;
          FBitmap.Width := W;
          FBitmap.Height := H;
          //VideoSample.SetCallBack(CallBack);  Does not work :(
        END;
    end;

  Screen.Cursor := crDefault;
  Application.ProcessMessages;
end;


procedure TVideoImage.OnNewFrame(VAR Msg: TMessage);
VAR
  W, H   : integer;
  FourCC : cardinal;
  hr     : HResult;
begin
  if  OnNewFrameBusy then
      exit;
  OnNewFrameBusy := true;
  try
    IF Msg.WParam <> fWidth*fHeight*3 then
      begin
        OnNewFrameBusy := false;
        exit;
      end;
    move(pointer(Msg.LParam)^, FBitmap.scanline[fHeight-1]^, Msg.WParam);
    if assigned(fDisplayCanvas) then
      IF fDisplayCanvas.LockCount < 1 then
        begin
          fDisplayCanvas.lock;
          try
            fDisplayCanvas.Draw(0, 0, fBitmap);
          finally
            fDisplayCanvas.unlock;
          end;
        end;
  finally
    OnNewFrameBusy := false;
  end;

end;


procedure TVideoImage.GetBitmap(BMP: TBitmap);
begin
  BMP.Assign(fBitmap);
end;


procedure TVideoImage.SetDisplayCanvas(Canvas: TCanvas);
begin
  fDisplayCanvas := Canvas;
end;

procedure TVideoImage.ShowProperty;
begin
  VideoSample.ShowPropertyDialog;
end;

procedure TVideoImage.ShowProperty_Stream;
var
  hr : HResult;
  W, H : integer;
  FourCC : cardinal;
begin
  VideoSample.ShowPropertyDialog_CaptureStream;
  hr := VideoSample.GetStreamInfo(W, H, FourCC);
  IF Failed(HR)
    then begin
      VideoStop;
    end
    else BEGIN
      fWidth := W;
      fHeight := H;
      FBitmap.PixelFormat := pf24bit;
      FBitmap.Width := W;
      FBitmap.Height := H;
    //  VideoSample.SetCallBack(CallBack);
    END;
end;


end.
